home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / libraries / string-ext / match.dylan < prev    next >
Encoding:
Text File  |  1995-03-15  |  13.8 KB  |  406 lines  |  [TEXT/ttxt]
  1. module:   regular-expressions
  2. author:   Nick Kramer (nkramer@cs.cmu.edu)
  3. synopsis: This takes a parsed regular expression and tries to find a match
  4.           for it.
  5. copyright:  Copyright (C) 1994, Carnegie Mellon University.
  6.             All rights reserved.
  7. rcs-header: $Header: match.dylan,v 1.1 94/11/08 22:57:02 nkramer Exp $
  8.  
  9. //======================================================================
  10. //
  11. // Copyright (c) 1994  Carnegie Mellon University
  12. // All rights reserved.
  13. // 
  14. // Use and copying of this software and preparation of derivative
  15. // works based on this software are permitted, including commercial
  16. // use, provided that the following conditions are observed:
  17. // 
  18. // 1. This copyright notice must be retained in full on any copies
  19. //    and on appropriate parts of any derivative works.
  20. // 2. Documentation (paper or online) accompanying any system that
  21. //    incorporates this software, or any part of it, must acknowledge
  22. //    the contribution of the Gwydion Project at Carnegie Mellon
  23. //    University.
  24. // 
  25. // This software is made available "as is".  Neither the authors nor
  26. // Carnegie Mellon University make any warranty about the software,
  27. // its performance, or its conformity to any specification.
  28. // 
  29. // Bug reports, questions, comments, and suggestions should be sent by
  30. // E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  31. //
  32. //======================================================================
  33.  
  34. define constant <non-local-exit> = <function>;
  35.  
  36. // Details of match:
  37.  
  38. // This whole thing is rather hairy.  Basically, it creates a "path"
  39. // through the regexp parse tree that corresponds to a match of the
  40. // string.  A path is a round trip through a parse tree that starts
  41. // and ends at the root. The part of the path already travelled is the
  42. // call stack, and hints about the untravelled part of the path are
  43. // stored as a list of functions called the up-proc-list.  (Whenever
  44. // you want to go "up" the parse tree, you call the first function in
  45. // the up-proc-list)
  46.  
  47. // Match-root? declares a few non-local exits to pass around, and then
  48. // calls descend-re to get things moving.  If the appropriate method
  49. // of descend-re is recursive (and most are), it puts its "up-proc" on
  50. // the up-proc-list, and makes a recursive call.  When the recursive
  51. // call is "done", it'll call the first function on the up-proc-list,
  52. // which happens to be the function we just put there.  This up-proc
  53. // will generally do some work, and then will either call descend-re
  54. // or will itself call the first thing on its up-proc-list.
  55.  
  56. // If descend-re determines this path is a dead end, it'll invoke a
  57. // backtrack function.  Each descend-re invocation generally sets up
  58. // its own non-local exit so that it can try to match its part
  59. // differently.
  60.  
  61. // As an example, a <union> is "regexp #1 or regexp #2".  When
  62. // descend-re(<union>...) is called, it'll set up a non-local exit and
  63. // then descend-re on regexp #1.  If someone backtracks out of regexp
  64. // #1, descend-re(<union>) will try regexp #2.  If someone backtracks
  65. // out of that, descend-re(<union>) will give up and backtrack itself.
  66.  
  67. // When this chain of functions completes a match, it'll stumble upon
  68. // the succeed up-proc that match-root? sets up.  Otherwise, it'll
  69. // backtrack until it gets to match-root?'s "fail" non-local exit.
  70.  
  71.  
  72. // Match-root?: Set things up and call descend-re.
  73. //
  74. define method match-root? (re :: <parsed-regexp>, string :: <string>, 
  75.                equal? :: <function>,
  76.                num-groups :: <integer>)
  77.     => (answer :: <boolean>, marks :: <sequence>);
  78.   let marks = make(<vector>, size: num-groups * 2, fill: #f);
  79.   let answer
  80.     = block (succeed)
  81.     local method up-proc (index :: <integer>, 
  82.                   backtrack :: <non-local-exit>, 
  83.                   up-list :: <list>);
  84.         succeed(#t);
  85.           end method up-proc;
  86.  
  87.        // Try each possible starting point.  As soon as a match is
  88.        // found, it'll quit via the success non-local exit.
  89.        // (and yes, that's *to* size(string), not *below* size(string))
  90.     for (index from 0 to size(string))
  91.       block (fail)
  92.         descend-re(re, string, equal?, index,
  93.                marks, fail, list(up-proc));
  94.         error("A regexp should either match or not match. Why did it "
  95.             "reach this piece of code?");
  96.       end block;
  97.     end for;
  98.     values(#f);      // Failure
  99.       end block;         // success block
  100.   values(answer, marks);
  101. end method match-root?;
  102.  
  103.  
  104. // Anchored-match-root?: Handles the simple case where the search string
  105. // starts with "^".
  106. //
  107. define method anchored-match-root? (re :: <parsed-regexp>, string :: <string>, 
  108.                     equal? :: <function>,
  109.                     num-groups :: <integer>)
  110.  => (answer :: <boolean>, marks :: <sequence>);
  111.   let marks = make(<vector>, size: num-groups * 2, fill: #f);
  112.   let answer
  113.     = block (succeed)
  114.     local method up-proc (index :: <integer>, 
  115.                   backtrack :: <non-local-exit>, 
  116.                   up-list :: <list>);
  117.         succeed(#t);
  118.           end method up-proc;
  119.  
  120.     block (fail)
  121.       descend-re(re, string, equal?, 0,
  122.              marks, fail, list(up-proc));
  123.       error("A regexp should either match or not match. Why did it "
  124.           "reach this piece of code?");
  125.     end block;
  126.     values(#f);      // Failure
  127.       end block;         // success block
  128.   values(answer, marks);
  129. end method anchored-match-root?;
  130.  
  131.  
  132. // Marks
  133. //
  134. define method descend-re (re :: <mark>, string :: <string>,
  135.               equal? :: <function>,
  136.               start-index :: <integer>,
  137.               marks :: <mutable-sequence>,
  138.               backtrack-past-me :: <non-local-exit>,
  139.               up-list :: <list>);
  140.  
  141.      // The up-proc makes a mark of where it is and calls the next up
  142.   local method up-proc (current-index :: <integer>, 
  143.             current-backtrack :: <non-local-exit>, 
  144.             current-up-list :: <list>)
  145.       marks[1 + 2 * re.group-number] := current-index;
  146.       head(current-up-list)(current-index, current-backtrack, 
  147.                 tail(current-up-list));
  148.     end method up-proc;
  149.  
  150.   let old-start-mark = marks[2 * re.group-number];
  151.   let old-end-mark = marks[1 + 2 * re.group-number];  
  152.            // Save this in case this path doesn't work out
  153.  
  154.   marks[2 * re.group-number] := start-index;
  155.  
  156.   block (backtrack-to-me)
  157.     descend-re(re.child, string, equal?, start-index,
  158.            marks, backtrack-to-me, pair(up-proc, up-list));
  159.   end block;
  160.  
  161.     // Since he backtracked, clean up the marks and backtrack to
  162.     // someone who cares.
  163.   marks[2 * re.group-number]     := old-start-mark;
  164.   marks[1 + 2 * re.group-number] := old-end-mark;
  165.   backtrack-past-me();
  166. end method descend-re;
  167.   
  168.  
  169. // Union: Try one path.  If you get a backtrack, try the other.
  170. //
  171. define method descend-re (re :: <union>, string :: <string>,
  172.               equal? :: <function>,
  173.               start-index :: <integer>,
  174.               marks :: <mutable-sequence>,
  175.               backtrack-past-me :: <non-local-exit>,
  176.               up-list :: <list>);
  177.  
  178.   block (backtrack-to-me)
  179.     descend-re(re.left, string, equal?, start-index,
  180.            marks, backtrack-to-me, up-list);
  181.   end block;
  182.  
  183.   // If we've gotten this far, it means that the user backtracked.
  184.   // Try the right, with the provision that we can do no more.
  185.  
  186.   descend-re(re.right, string, equal?, start-index,
  187.          marks, backtrack-past-me, up-list);
  188. end method descend-re;
  189.  
  190.  
  191. // At present the only way this should be called is if a "union" has
  192. // only one branch.  (This happens when union is used to mark a group
  193. // or override precedence rather than actually indicating multiple
  194. // paths)  So, just backtrack.
  195. //
  196. define method descend-re (re :: singleton(#f), string :: <string>,
  197.               equal? :: <function>,
  198.               start-index :: <integer>,
  199.               marks :: <mutable-sequence>,
  200.               backtrack-past-me :: <non-local-exit>,
  201.               up-list :: <list>);
  202.   backtrack-past-me();
  203. end method descend-re;
  204.  
  205.  
  206. // Concatenation
  207. //
  208. define method descend-re (re :: <alternative>, string :: <string>,
  209.               equal? :: <function>,
  210.               start-index :: <integer>,
  211.               marks :: <mutable-sequence>,
  212.               backtrack-past-me :: <non-local-exit>,
  213.               up-list :: <list>);
  214.     // up-proc is "Ok, we've matched on the left, now match on the
  215.     // right".  If it matches, we don't ever hear about it because we
  216.     // put nothing on the up-list.
  217.   local method up-proc (current-index :: <integer>, 
  218.             current-backtrack :: <non-local-exit>,
  219.             current-up-list :: <list>)
  220.       descend-re(re.right, string, equal?, current-index, marks, 
  221.              current-backtrack, current-up-list);
  222.     end method up-proc;
  223.  
  224.   descend-re(re.left, string, equal?, start-index, marks,
  225.          backtrack-past-me, pair(up-proc, up-list));
  226. end method descend-re;
  227.   
  228.  
  229. // Assertions
  230. //
  231. define method descend-re (re :: <parsed-assertion>, string :: <string>,
  232.               equal? :: <function>,
  233.               start-index :: <integer>,
  234.               marks :: <mutable-sequence>,
  235.               backtrack-past-me :: <non-local-exit>,
  236.               up-list :: <list>);
  237.   if (assertion-true?(re.asserts, string, start-index, equal?))
  238.     head(up-list)(start-index, backtrack-past-me, tail(up-list));
  239.   else
  240.     backtrack-past-me();
  241.   end if;
  242. end method descend-re;
  243.   
  244.  
  245. // Quantified atoms
  246. //
  247. define method descend-re (re :: <quantified-atom>, string :: <string>,
  248.               equal? :: <function>,
  249.               start-index :: <integer>,
  250.               marks :: <mutable-sequence>,
  251.               backtrack-past-me :: <non-local-exit>,
  252.               up-list :: <list>);
  253.  
  254.   local method descend-and-quantify (min :: <integer>, max, 
  255.                      re :: <parsed-regexp>, index :: <integer>,
  256.                      backtrack-past-me :: <non-local-exit>,
  257.                      up-list)
  258.  
  259.       local method keep-quantifying (new-index :: <integer>, 
  260.                      backtrack :: <non-local-exit>, 
  261.                      up-list :: <list>)
  262.           if (new-index = index  &  min <= 1)
  263.             backtrack();
  264.                  // The longest thing matched was length 0.
  265.                  // If we don't quit now, we could get
  266.                  // stuck in an infinite loop.
  267.  
  268.                  // This will give a false negative in some
  269.                  // cases where the atom being quantified can
  270.                  // match the empty string (like (a*|b)*), but
  271.                  // Perl rejects it at parse time, so this
  272.                  // solution is not really any worse than
  273.                  // anyone else's.
  274.           else
  275.             descend-and-quantify(min - 1, max & (max - 1), re,
  276.                      new-index, backtrack, up-list);
  277.           end if;
  278.         end method keep-quantifying;
  279.  
  280.       if (max = 0)    // Go up
  281.         head(up-list)(index, backtrack-past-me, tail(up-list));
  282.  
  283.       elseif (min > 0) // Mandatory match
  284.         descend-re(re, string, equal?, index, marks, backtrack-past-me, 
  285.                pair(keep-quantifying, up-list));
  286.  
  287.       else   // We've made enough matches, but we'd like to make more
  288.         block (backtrack-to-me)
  289.           descend-re(re, string, equal?, index, marks, backtrack-to-me, 
  290.              pair(keep-quantifying, up-list));
  291.         end block;
  292.            // If we reach here, there was a backtrack. Give up on
  293.            // the idea of trying to match more.
  294.         head(up-list)(index, backtrack-past-me, tail(up-list));
  295.       end if;
  296.     end method descend-and-quantify;
  297.  
  298.   descend-and-quantify(re.min-matches, re.max-matches, re.atom,
  299.                start-index, backtrack-past-me, up-list);
  300. end method descend-re;
  301.  
  302.  
  303. // Characters
  304. //
  305. define method descend-re (re :: <parsed-character>, string :: <string>,
  306.               equal? :: <function>,
  307.               start-index :: <integer>,
  308.               marks :: <mutable-sequence>,
  309.               backtrack-past-me :: <non-local-exit>,
  310.               up-list :: <list>);
  311.   if (equal?(re.character, element(string, start-index, default: #f)))
  312.     head(up-list)(start-index + 1, backtrack-past-me, tail(up-list));
  313.   else
  314.     backtrack-past-me();
  315.   end if;
  316. end method descend-re;
  317.  
  318.  
  319. // Character set
  320. //
  321. define method descend-re (re :: <parsed-set>, string :: <string>,
  322.               equal? :: <function>,
  323.               start-index :: <integer>,
  324.               marks :: <mutable-sequence>,
  325.               backtrack-past-me :: <non-local-exit>,
  326.               up-list :: <list>);
  327.   if (start-index < size(string)  
  328.     & member?(string[start-index], re.char-set))
  329.     head(up-list)(start-index + 1, backtrack-past-me, tail(up-list));
  330.   else
  331.     backtrack-past-me();
  332.   end if;
  333. end method descend-re;
  334.  
  335.  
  336. // Backreferences
  337. //
  338. define method descend-re (re :: <parsed-backreference>, string :: <string>,
  339.               equal? :: <function>,
  340.               start-index :: <integer>,
  341.               marks :: <mutable-sequence>,
  342.               backtrack-past-me :: <non-local-exit>,
  343.               up-list :: <list>);
  344.   let backref-start = marks[2 * re.group-number];
  345.   let backref-end = marks[1 + 2 * re.group-number];
  346.   let substring-2-end-pos = start-index + (backref-end - backref-start);
  347.  
  348.   if (substrings-equal?(equal?, 
  349.             string, backref-start, backref-end,
  350.             string, start-index, substring-2-end-pos))
  351.     head(up-list)(substring-2-end-pos, backtrack-past-me, tail(up-list));
  352.   else
  353.     backtrack-past-me();
  354.   end if;
  355. end method descend-re;
  356.       
  357. /* --------------------------------------------------------------- */
  358. // Supporting routines
  359. /* --------------------------------------------------------------- */
  360.  
  361. // Efficiently compare two substrings, using a provided character by
  362. // character equal? predicate.
  363. //
  364. define method substrings-equal? (equal? :: <function>,
  365.                  string1 :: <string>, 
  366.                  start1 :: <integer>, end1 :: <integer>,
  367.                  string2 :: <string>, 
  368.                  start2 :: <integer>, end2 :: <integer>)
  369.     => answer :: <boolean>;
  370.   if (end1 - start1 ~= end2 - start2)
  371.     #f;
  372.   else
  373.     block (return)
  374.       for (index1 from start1 to end1, index2 from start2)
  375.     if (~ equal?(string1[index1], string2[index2]))
  376.       return(#f);
  377.     end if;
  378.       end for;
  379.       #t;
  380.     end block;
  381.   end if;
  382. end method substrings-equal?;
  383.  
  384.  
  385. define method assertion-true? (assertion :: <symbol>, string :: <string>, 
  386.                    index :: <integer>, equal? :: <function>)
  387.     => answer :: <boolean>;
  388.   select (assertion)
  389.     #"final-state"         => #t;
  390.     #"beginning-of-string" => index = 0;
  391.     #"end-of-string"       => index >= size(string);
  392.     #"word-boundary"       =>
  393.       index = 0 | index >= size(string)
  394.     | (member?(string[index], whitespace-chars) 
  395.          ~= member?(string[index - 1], whitespace-chars));
  396.  
  397.     #"not-word-boundary"   =>
  398.       index ~= 0 & index < size(string)
  399.     & (member?(string[index], whitespace-chars)
  400.          = member?(string[index - 1], whitespace-chars));
  401.  
  402.     otherwise              => 
  403.       error("Unknown assertion %=", assertion.asserts);
  404.   end select;
  405. end method assertion-true?;
  406.